Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/CWTPU11/CWARE.PAS

Pascal/Delphi Source File | 1989-11-07 | 25KB | 729 lines

{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}

Unit CWare;

(* Version 1.1 - CollisionWare Premium SoftWare - Compiled by Kito Mann *)
(* This unit is a simple collection of some some procedures aquired     *)
(* from other programs and myself. New versions will have added         *)
(* procedures, and the present ones will be improved. Comments, bugs,   *)
(* and questions accepted.                                              *)
(* Keep in mind that there is NO WARANTY! It IS NOT GAURANTEED that all *)
(* these procedures will work!                                          *)
(* If you modify the procedures included, or add your own, I request    *)
(* that you send me a copy of the new unit and source code.             *)

(* It'd probably be helpful if you declare ErrorCode: byte in your main *)
(* program. It is used as an Error variable much like the DosError used *)
(* in the DOS unit.                                                     *)

(* The Collision Theory pm-BBS *)
(*         24 hours            *)
(*      [phone]          * <--- NUMBER AND HOUR CHANGE! *)
(*         Burke, VA           *)
(* "Dedicated to Intelligent   *)
(*        Conversation"        *)

INTERFACE

Uses Crt,
     Dos;

const
  MaxDirEnteries=       20;    { Maximum number of directories that can be specified to search }
                               { This doesn't include those searched "below" ones specified.   }

type
  FullNameStr=          string[12];                 { Type for storing name+dot+extention                                 }
  DirSearchEntry=       record                      { This data type is used to store all the paths that will be searched }
                          Dir:         DirStr;      {   <-- Path to search                                                }
                          Name:        FullNameStr; {   <-- File spec to search                                           }
                          Below:       boolean;     {   <-- TRUE=search directories below the specified one               }
                        end;
  ProcType=             procedure(var S: SearchRec; P: PathStr);
  AnyStr=               string[255];


var
  EngineMask:           FullNameStr;
  EngineAttr:           byte;
  EngineProc:           ProcType;
  EngineCode:           byte;

  Reg:                  Registers;   { Register storage for DOS calls }
  OldSeg,OldOfs:        word;
  BufData:              longint;
  BufferSeg:            word;
  BufferOfs:            word;
  BufferLen:            word;
  BufferPtr:            pointer;
  T:                    text;
  P:                    PathStr;


(* File and Keyboard Buffer procedures *)

function FileFound(F: ComStr): boolean;

procedure SearchEngine(Mask: PathStr; Attr: byte; Proc: ProcType; var ErrorCode: byte);

function GoodDirectory(S: SearchRec): boolean;

procedure SearchOneDir(var S: SearchRec; P: PathStr);

procedure SearchEngineAll(Path: PathStr; Mask: FullNameStr; Attr: byte;
                          Proc: ProcType; var ErrorCode: byte);

procedure IPP;

procedure NewExitProc2;

procedure ResetBuffer;

function BufSize: word;

function InBuffer(S: string): integer;

procedure InstallInterruptHandler;

procedure DeleteFiles(P: string);

procedure DeleteDir(P:string);

procedure ListFiles(P: string; complete:boolean; pausenum:integer);

(* Misc. String procedures *)

function DateString: string;

function TimeString: string;

procedure Tab(s1,s2:AnyStr; i:integer);

Function UpCaseString(StrIn : String) : String;
{ Convert a string to upper case }

Function PathOnly(FileName : String) : String;
{ Strip any filename information from a file specification }

Function NameOnly(FileName : String) : String;
{ Strip any path information from a file specification }

Function BaseNameOnly(FileName : String) : String;
{ Strip any path and extension information from a file specification }

Function ExtOnly(FileName : String) : String;
{ Return only the extension portion of a filename }

Function IntStr(Int : LongInt; Form : Integer) : String;
{ Convert an Integer variable to a string }

Function Strr(Int:LongInt) : String;
{ Same as IntStr but does not use the variable "Form" }

Function SameFile(File1, File2 : String) : Boolean;
{ Call to find out if File1 has a name equivalent to File2.  Both filespecs }
{ may contain wildcards.                                                    }


IMPLEMENTATION

{ -------------------------------------------------------------------------- }

function FileFound(F: ComStr): boolean;
{
  This returns TRUE if the file F exists, FALSE otherwise.  F can contain
  wildcard characters.
}
var
  SRec:                 SearchRec;
begin
  SRec.Name := '*';
  FindFirst(F,0,SRec);
  if SRec.Name='*' then FileFound := false else FileFound := true;
end;


(********* The following search engine routines are sneakly swiped *********)
(********* from Turbo Technix v1n6.  See there for further details *********)

procedure SearchEngine(Mask: PathStr; Attr: byte; Proc: ProcType;
                       var ErrorCode: byte);
var
  S:                    SearchRec;
  P:                    PathStr;
  Ext:                  ExtStr;
begin
  FSplit(Mask, P, Mask, Ext);
  Mask := Mask+Ext;
  FindFirst(P+Mask,Attr,S);
  if DosError<>0 then
  begin
    ErrorCode := DosError;
    exit;
  end;
  while DosError=0 do
  begin
    Proc(S, P);
    FindNext(S);
  end;
  if DosError=18 then ErrorCode := 0
  else ErrorCode := DosError;
end;

{ -------------------------------------------------------------------------- }

function GoodDirectory(S: SearchRec): boolean;
begin
  GoodDirectory := (S.name<>'.') and (S.Name<>'..') and
  (S.Attr and Directory=Directory);
end;

{ -------------------------------------------------------------------------- }

procedure SearchOneDir(var S: SearchRec; P: PathStr);
begin
  if GoodDirectory(S) then
  begin
    P := P+S.Name;
    SearchEngine(P+'\'+EngineMask,EngineAttr,EngineProc,EngineCode);
    SearchEngine(P+'\*.*',Directory or Archive, SearchOneDir,EngineCode);
  end;
end;

{ -------------------------------------------------------------------------- }

procedure SearchEngineAll(Path: PathStr; Mask: FullNameStr; Attr: byte;
                          Proc: ProcType; var ErrorCode: byte);
begin
  EngineMask := Mask;
  EngineProc := Proc;
  EngineAttr := Attr;
  SearchEngine(Path+Mask,Attr,Proc,ErrorCode);
  SearchEngine(Path+'*.*',Directory or Archive,SearchOneDir,ErrorCode);
  ErrorCode := EngineCode;
end;

(************** Thus ends the sneakly swiped code *************)

{ -------------------------------------------------------------------------- }

procedure IPP;
{ Interrupt pre-processor.  This is a new handler for interrupt 29h which
  provides special functions.  See comments in IHAND.ASM}
begin
  InLine(
      $06/                   {          push    es                      }
      $1E/                   {          push    ds                      }
      $53/                   {          push    bx                      }
      $57/                   {          push    di                      }
      $BB/$3F/$3F/           {          mov     bx, 3f3fh               }
      $8E/$C3/               {          mov     es, bx                  }
      $BB/$3F/$3F/           {          mov     bx, 3f3fh               }
      $26/$8B/$3F/           {          mov     di, word ptr [es:bx]    }
      $26/$8E/$5F/$02/       {          mov     ds, word ptr [es:bx+2]  }
      $88/$05/               {          mov     byte ptr [di], al       }
      $26/$FF/$07/           {          inc     word ptr [es:bx]        }
      $5F/                   {          pop     di                      }
      $5B/                   {          pop     bx                      }
      $1F/                   {          pop     ds                      }
      $07/                   {          pop     es                      }
      $3C/$0A/               {          cmp     al, 10                  }
      $75/$28/               {          jne     looper                  }
      $50/                   {          push    ax                      }
      $52/                   {          push    dx                      }
      $51/                   {          push    cx                      }
      $53/                   {          push    bx                      }
      $B4/$03/               {          mov     ah, 3                   }
      $B7/$00/               {          mov     bh, 0                   }
      $CD/$10/               {          int     10h                     }
      $80/$FE/$18/           {          cmp     dh, 24                  }
      $75/$15/               {          jne     popper                  }
      $FE/$CE/               {          dec     dh                      }
      $B7/$00/               {          mov     bh, 0                   }
      $B4/$02/               {          mov     ah, 2                   }
      $CD/$10/               {          int     10h                     }
      $B8/$01/$06/           {          mov     ax, 0601h               }
      $B7/$07/               {          mov     bh, 7                   }
      $B9/$00/$11/           {          mov     cx, 1100h               }
      $BA/$4F/$18/           {          mov     dx, 184fh               }
      $CD/$10/               {          int     10h                     }
      $5B/                   {  popper: pop     bx                      }
      $59/                   {          pop     cx                      }
      $5A/                   {          pop     dx                      }
      $58/                   {          pop     ax                      }
      $9C/                   {  looper: pushf                           }
      $9A/$00/$00/$00/$00/   {          call    far [0:0]               }
      $CF);                  {          iret                            }
end;

{ -------------------------------------------------------------------------- }

procedure NewExitProc2;
{ This exit procedure removes the interrupt 29h handler from memory and places
  the cursor at the bottom of the screen. }
begin
  Reg.AH := $25;
  Reg.AL := $29;
  Reg.DS := OldSeg;
  Reg.DX := OldOfs;
  MsDos(Reg);
  Window(1,1,80,25);
  GotoXY(1,24);
  TextAttr := $07;
  ClrEol;
end;

{ -------------------------------------------------------------------------- }

procedure ResetBuffer;
{ Reset pointers to the text buffer, effectivly deleting any text in it }
begin
  MemW[seg(BufData):ofs(BufData)] := BufferOfs;    { Set first 2 bytes of BufData to point to buffer offset }
  MemW[seg(BufData):ofs(BufData)+2] := BufferSeg;  { And next two bytes to point to buffer segment }
  MemW[seg(IPP):ofs(IPP)+21] := seg(BufData);    { Now point the interrupt routine to BufData for pointer }
  MemW[seg(IPP):ofs(IPP)+26] := ofs(BufData);    {  to the text buffer }
end;

{ -------------------------------------------------------------------------- }

function BufSize: word;
{ This returns the number of characters in the text buffer.  It's what BufData
  now points to minus what is origionally pointed to, eg, the number of times
  IPP incremented it }
begin
  BufSize := MemW[seg(BufData):ofs(BufData)]-BufferOfs;
end;

{ -------------------------------------------------------------------------- }

function InBuffer(S: string): integer;
{ This searched the text buffer for the string S, and if it's found returns
  the offset in the buffer.  If it's not found a -1 is returned }
var
  L,M:                  word;
  X:                    byte;
begin
  X := 1;
  L := BufferOfs;
  M := BufSize;
  while (X<=length(S)) and (L<=M) do
  begin
    if Mem[BufferSeg:L]=byte(S[X]) then Inc(X) else X := 1;
    Inc(L);
  end;
  if X>length(S) then InBuffer := L-length(S) else InBuffer := -1;
end;

{ -------------------------------------------------------------------------- }

procedure InstallInterruptHandler;
{ Installs the int 29h handler }
begin
  BufferLen := $4000;  { Set up a 16k buffer }
  GetMem(BufferPtr,BufferLen);  { Allocate memory pointed at by BufferPtr }
  BufferSeg := seg(BufferPtr^);  { Read segment and offset of buffer for easy access }
  BufferOfs := ofs(BufferPtr^);
  ResetBuffer;    { Place these values in the IPP routine, resetting buffer }
  Reg.AH := $35;
  Reg.AL := $29;  { DOS service 35h, get interrupt vector for 29h }
  MsDos(Reg);
  OldSeg := Reg.ES;   { Store the segment and offset of the old vector for later use }
  OldOfs := Reg.BX;
  MemW[seg(IPP):ofs(IPP)+90] := Reg.BX;  { And store them so IPP can call the routine }
  MemW[seg(IPP):ofs(IPP)+92] := Reg.ES;
  Reg.AL := $29; { DOS service 25h, set interrupt vector 29h }
  Reg.AH := $25;
  Reg.DS := seg(IPP);    { Store segment and offset for IPP.  The +16 is to skip TP stack }
  Reg.DX := ofs(IPP)+16; { maintainence routines }
  MsDos(Reg);
end;

{ -------------------------------------------------------------------------- }

  procedure DeleteFiles(P: string);
  {
    Delete all files in the directory named, including
    Hidden, Read-only, System and other file types.
  }
  var
    SRec:               SearchRec;
    ErrorCode:          byte;
  begin
    FindFirst(P+'\*.*',0,SRec);
    while DosError=0 do
    begin
      Assign(T, P+'\'+SRec.Name);
      SetFAttr(T,Archive);
      writeln('Deleting ',P,+'\'+Srec.Name);
      {$I-}
      Erase(T);
      {$I+}
      ErrorCode := IOResult;
      FindNext(SRec);
    end;
    ErrorCode := IOResult;
end;

{ -------------------------------------------------------------------------- }

procedure DeleteDir(P:string);

{ Simply deletes specified directory }

var ErrorCode: byte;
begin
  DeleteFiles(P);
  {$I-}
  RmDir(P);
  {$I+}
  ErrorCode := IOResult;
end;

{ -------------------------------------------------------------------------- }

procedure ListFiles(P: string; complete:boolean; pausenum:integer);
  {
   If complete is true then will show the name and file size of every
   file. Otherwise will just show the filename. Numlines is the number
   of files it will display before a pause. 0 means no pause.
  }
  var
    SRec:               SearchRec;
    ErrorCode:          byte;
    Size:               AnyStr;
    Index:              integer;
    TheChar:            char;
    Quit:               boolean;

  begin
    Quit:=false;
    FindFirst(P+'\*.*',0,SRec);
    Index:=1;
    while DosError=0 do
    begin
       if Index=pausenum then
       begin
        write('[Q=quit, ANY KEY=continue]:');
        TheChar:=UpCase(ReadKey); writeln(TheChar);
        if TheChar='Q' then quit:=true;
        writeln;
        Index:=0;
       end;
      if NOT Quit then
      if complete then begin
        Size:=strr(Srec.Size);
        tab(Srec.Name,Size,15);
        writeln;
      end else
      writeln(Srec.Name);
      FindNext(SRec);
      Inc(Index);
    end;
    ErrorCode := IOResult;
end;

{ -------------------------------------------------------------------------- }

  function DateString: string;
  {
    Returns the current date in a string of the form:  MON ## YEAR.
    E.g, 21 Feb 1989 or 02 Jan 1988.
  }
  const
    Month:              array[1..12] of string[3]=
                        ('Jan','Feb','Mar','Apr','May','Jun',
                         'Jul','Aug','Sep','Oct','Nov','Dec');
  var
    Y,M,D,Junk:         word;
    DS,YS:              string[5];
  begin
    GetDate(Y,M,D,Junk);
    Str(Y,YS);
    Str(D,DS);
    if length(DS)<2 then DS := '0'+DS;
    DateString := DS+' '+Month[M]+' '+YS;
  end;

{ -------------------------------------------------------------------------- }

  function TimeString: string;
  {
    Returns the current time in the form:  HH:MM am/pm
    E.g, 12:00 am or 09:12 pm.
  }
  var
    H,M,Junk:           word;
    HS,MS:              string[5];
    Am:                 boolean;
  begin
    GetTime(H,M,Junk,Junk);
    case H of
      0:     begin
               Am := true;
               H := 12;
             end;
      1..11: Am := true;
      12:    Am := false;
      else   begin
               Am := false;
               H := H-12;
             end;
    end;
    Str(H,HS);
    Str(M,MS);
    if length(HS)<2 then HS := '0'+HS;
    if length(MS)<2 then MS := '0'+MS;
    if Am then TimeString := HS+':'+MS+' am'
    else TimeString := HS+':'+MS+' pm';
  end;

{ -------------------------------------------------------------------------- }

procedure Tab(s1,s2:AnyStr; i:integer);

{ Writes s1, then goes to i-length(s1) and writes s2 }

var j,k:integer;
begin
  j:=length(s1);
  i:=i-j;
  write(s1);
  for k:=1 to i do write(' ');
  write(s2);
end;

{ -------------------------------------------------------------------------- }

Function UpCaseString(StrIn : String) : String;
Begin
   Inline(                   { Thanks to Phil Burns for this routine }

      $1E/                   {         PUSH    DS                ; Save DS}
      $C5/$76/$06/           {         LDS     SI,[BP+6]         ; Get source string address}
      $C4/$7E/$0A/           {         LES     DI,[BP+10]        ; Get result string address}
      $FC/                   {         CLD                       ; Forward direction for strings}
      $AC/                   {         LODSB                     ; Get length of source string}
      $AA/                   {         STOSB                     ; Copy to result string}
      $30/$ED/               {         XOR     CH,CH}
      $88/$C1/               {         MOV     CL,AL             ; Move string length to CL}
      $E3/$0E/               {         JCXZ    Exit              ; Skip if null string}
                             {;}
      $AC/                   {UpCase1: LODSB                     ; Get next source character}
      $3C/$61/               {         CMP     AL,'a'            ; Check if lower-case letter}
      $72/$06/               {         JB      UpCase2}
      $3C/$7A/               {         CMP     AL,'z'}
      $77/$02/               {         JA      UpCase2}
      $2C/$20/               {         SUB     AL,'a'-'A'        ; Convert to uppercase}
                             {;}
      $AA/                   {UpCase2: STOSB                     ; Store in result}
      $E2/$F2/               {         LOOP    UpCase1}
                             {;}
      $1F);                  {Exit:    POP     DS                ; Restore DS}

end {UpCaseString};

{ -------------------------------------------------------------------------- }

Function PathOnly(FileName : String) : String;
Var
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
Begin
   FSplit(FileName, Dir, Name, Ext);
   PathOnly := Dir;
End {PathOnly};

{ --------------------------------------------------------------------------- }

Function NameOnly(FileName : String) : String;
{ Strip any path information from a file specification }
Var
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
Begin
   FSplit(FileName, Dir, Name, Ext);
   NameOnly := Name + Ext;
End {NameOnly};

{ --------------------------------------------------------------------------- }

Function BaseNameOnly(FileName : String) : String;
{ Strip any path and extension from a file specification }
Var
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
Begin
   FSplit(FileName, Dir, Name, Ext);
   BaseNameOnly := Name;
End {BaseNameOnly};

{ --------------------------------------------------------------------------- }

Function ExtOnly(FileName : String) : String;
{ Strip the path and name from a file specification.  Return only the }
{ filename extension.                                                 }
Var
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
Begin
   FSplit(FileName, Dir, Name, Ext);
   If Pos('.', Ext) <> 0 then
      Delete(Ext, 1, 1);
   ExtOnly := Ext;
End {ExtOnly};

{ --------------------------------------------------------------------------- }

Function IntStr(Int : LongInt; Form : Integer) : String;
Var
   S : String;
Begin
   If Form = 0 then
      Str(Int, S)
   else
      Str(Int:Form, S);
   IntStr := S;
End {IntStr};

{ --------------------------------------------------------------------------- }

Function Strr(Int : LongInt) : String; { Added for my own sake - KM }
Var
   S : String;
Begin
   Str(Int, S);
   Strr := S;
End {Strr};

{ --------------------------------------------------------------------------- }

Function SameName(N1, N2 : String) : Boolean;
{
  Function to compare filespecs.

  Wildcards allowed in either name.
  Filenames should be compared seperately from filename extensions by using
     seperate calls to this function
        e.g.  FName1.Ex1
              FName2.Ex2
              are they the same?
              they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)

  Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
  match just any file...only those with 'XX' as the last two characters of
  the name portion and 'DAT' as the extension).

  This routine calls itself recursively to resolve wildcard matches.

}
Var
   P1, P2 : Integer;
   Match  : Boolean;
Begin
   P1    := 1;
   P2    := 1;
   Match := TRUE;

   If (Length(N1) = 0) and (Length(N2) = 0) then
      Match := True
   else
      If Length(N1) = 0 then
         If N2[1] = '*' then
            Match := TRUE
         else
            Match := FALSE
      else
         If Length(N2) = 0 then
            If N1[1] = '*' then
               Match := TRUE
            else
               Match := FALSE;

   While (Match = TRUE) and (P1 <= Length(N1)) and (P2 <= Length(N2)) do
      If (N1[P1] = '?') or (N2[P2] = '?') then begin
         Inc(P1);
         Inc(P2);
      end {then}
      else
         If N1[P1] = '*' then begin
            Inc(P1);
            If P1 <= Length(N1) then begin
               While (P2 <= Length(N2)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
                  Inc(P2);
               If P2 > Length(N2) then
                  Match := FALSE
               else begin
                  P1 := Succ(Length(N1));
                  P2 := Succ(Length(N2));
               end {if};
            end {then}
            else
               P2 := Succ(Length(N2));
         end {then}
         else
            If N2[P2] = '*' then begin
               Inc(P2);
               If P2 <= Length(N2) then begin
                  While (P1 <= Length(N1)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
                     Inc(P1);
                  If P1 > Length(N1) then
                     Match := FALSE
                  else begin
                     P1 := Succ(Length(N1));
                     P2 := Succ(Length(N2));
                  end {if};
               end {then}
               else
                  P1 := Succ(Length(N1));
            end {then}
            else
               If UpCase(N1[P1]) = UpCase(N2[P2]) then begin
                  Inc(P1);
                  Inc(P2);
               end {then}
               else
                  Match := FALSE;

   If P1 > Length(N1) then begin
      While (P2 <= Length(N2)) and (N2[P2] = '*') do
         Inc(P2);
      If P2 <= Length(N2) then
         Match := FALSE;
   end {if};

   If P2 > Length(N2) then begin
      While (P1 <= Length(N1)) and (N1[P1] = '*') do
         Inc(P1);
      If P1 <= Length(N1) then
         Match := FALSE;
   end {if};

   SameName := Match;

End {SameName};

{ ---------------------------------------------------------------------------- }

Function SameFile(File1, File2 : String) : Boolean;
Var
   Path1, Path2 : String;
Begin

   File1 := FExpand(File1);
   File2 := FExpand(File2);
   Path1 := PathOnly(File1);
   Path2 := PathOnly(File2);

   SameFile := SameName(BaseNameOnly(File1), BaseNameOnly(File2)) AND
               SameName(ExtOnly(File1), ExtOnly(File2))           AND
               (Path1 = Path2);

End {SameFile};

{ ---------------------------------------------------------------------------- }

End {Unit CWARE}.